perm filename MATCH.FOO[PAT,LMM] blob
sn#044102 filedate 1973-05-18 generic text, type T, neo UTF8
␈↓α(FILECREATED "18-MAY-73 4:42:12" MATCH.NEW)␈↓↓
(LISPXPRINT (QUOTE MATCHVARS)
T)
(RPAQQ MATCHVARS
((FNS MAKEMATCH 'MATCHTOP 'MATCH 'MATCHBIND 'MATCHELT
'MATCHEXP 'MATCHFIXED 'MATCHSUBPAT 'MATCHTAIL 'MATCHSOME
'MATCHWITHMEMB 'MATCHNNIL 'MATCHEXP1 LOCALPATVAR
'MATCH&SET 'CDRLEN POSTPONE 'HEADP ABP RPLNODE)
(FNS ANALPATELT ANALPAT MAXANAL ANAL!PAT $? SKIP$I SKIP$
SKIP$ANY ELT? MEMBPAT? ARB? NOMATCHARB? NOMATCHELT?
SUBPAT? NOMATCHARBCAR? NULLPAT? CANMATCHNIL)
(FNS EASYTORECOMPUTE EQTOMEMB FULLEXPANSION GENSYML MAKESUBST
MAKESUBST1 FORMEXPAND BIND BOUNDVAR RECOMPUTATION
MAKEVAR)
(FNS 'NLEFT 'NOT 'NOTLESSPLENGTH 'NTH 'NTH{NUMBER⎇ 'OR 'PLUS
'REPLACE 'SETQ←SIDE←EFFECT 'REPLACE←SIDE←EFFECT 'SETQ
'SETVAR 'SOME 'AND '!AND OPTIMIZEAND 'CAR 'CDR 'EQ
'EQLENGTH 'EQUAL 'LENGTH 'LISTP 'NULL 'LAST 'TAILP
'LDIFF 'RETURN)
(FNS PARSE PATPARSE NUMPATPARSE PATPARSE1 PATPARSE← BI12
PATPARSEAT PACKLDIFF BISET BIRPLAC MAKEDEFAULT
MAKE!DEFAULT)
(FNS HEADP)
(VARS POSTPONE←SIDE←EFFECTS VARDEFAULT LISTPCHK ORSETQFLG)
(BLOCKS * MATCHBLOCKS)
(PROP MACRO EVERY SOME)))
␈↓α(DEFINEQ␈↓↓
␈↓α(MAKEMATCH␈↓↓
[LAMBDA (VAR TOPPAT)
('MATCHTOP VAR (PATPARSE (COPY TOPPAT])
␈↓α('MATCHTOP␈↓↓
[LAMBDA (EXPR PAT MUSTBEMATCH)
(* Generate expresion which will match PAT against
VAR -
MUSTBEMATCH is a flag which says if the value of the
expression must be NIL if no match occurs and non
NIL otherwise -
ORSETQFLG is flag for setting whether setqs that
might be NIL should be embedded in
(OR (SETQ --) T) -
NULLCHK is flag for setting whether there is an
implicit -- at the end of each pattern -
LISTPCHK is flag for whether sub-patterns should
check LISTP first -
VARDEFAULT is flag which says what the default
meaning of a variable in a pattern is
(either set for (... Var←$1 ...) or QUOTE for
(... 'var ...) or equal for
(... =VAR ...)) -
POSTPONE←SIDE←EFFECTS is a flag which says whether
side effects (... pat←expr ...) or
(... var←pat ...) should be postponed and only done
if the entire pattern matches)
(PROG (POSTPONEDEFFECTS SOMEVARS EXPRESSION BINDINGS VAR
(GENSYMVARLIST (QUOTE (NIL $$1 $$2 $$3 $$4
$$5 $$6 $$7 $$8
$$9 $$10 $$11
$$12 $$13 $$14
$$15 $$16 $$17)))
(EASYFNS (QUOTE (CAR CDR)))
(MUSTBEMATCH T)
(NULLCHK T)
(MUSTRETURN T))
[COND
((EASYTORECOMPUTE EXPR)
(SETQ VAR EXPR))
(T (BIND (LIST (SETQ VAR (GENSYML EXPR))
EXPR]
(SETQ EXPRESSION ('MATCH VAR PAT))
(AND MUSTRETURN (SETQ POSTPONEDEFFECTS (NCONC1
POSTPONEDEFFECTS
MUSTRETURN)))
[AND POSTPONEDEFFECTS (SETQ EXPRESSION
('AND EXPRESSION (COND
((CDR POSTPONEDEFFECTS)
(CONS (QUOTE PROGN)
POSTPONEDEFFECTS))
(T (CAR POSTPONEDEFFECTS]
(RETURN (COND
(BINDINGS (LIST (QUOTE PROG)
BINDINGS EXPRESSION))
(T EXPRESSION])
␈↓α('MATCH␈↓↓
[LAMBDA (VAR PAT) (* Constructs match of
PAT against VAR -
See 'MATCHTOP for global
vars)
(PROG (TAIL (LEN 0))
(COND
((NULL PAT)
('EQLENGTH VAR 0))
((NLISTP PAT)
(HELP "BAD PARSING - NLISTP PAT IN 'MATCH" PAT))
((NULL (SETQ TAIL (SKIP$I PAT)))
(* PAT is a list of $i's -
SKIP$I returns the first tail after all $i's, sets
the variable LEN to the length of the $i's)
('EQLENGTH VAR LEN))
((NULLPAT? TAIL) (* PAT is a list of $i's
followed by a $)
('NOTLESSPLENGTH VAR LEN))
[(NOT (ZEROP LEN))
(* PAT starts with a list of $i's -
'MATCHEXP is called here instead of 'MATCH because
the 'NTH expression might not be EASYTORECOMPUTE)
(COND
((NUMBERP LEN)
('MATCH ('NTH{NUMBER⎇ VAR (ADD1 LEN))
TAIL))
(T ('MATCHEXP ('NTH VAR ('PLUS 1 LEN))
TAIL]
[(ELT? (CAR PAT))
(COND
((NULLPAT? (CDR PAT))
('MATCHELT ('CAR VAR)
(CAR PAT)
MUSTBEMATCH))
(T ('AND ('MATCHELT ('CAR VAR)
(CAR PAT)
T NIL)
('MATCH ('CDR VAR)
(CDR PAT]
(($? (CAR PAT))
('MATCHTAIL VAR (CDR PAT)))
((NLISTP (CAR PAT))
(HELP (QUOTE "BAD PATTERN ELEMENT")
PAT))
((NLISTP (CAAR PAT))
(SELECTQ
(CAAR PAT)
[← (* Only segment SETS get
here)
(COND
((NULL (CDR PAT)) (* Call 'MATCHBIND to
rebind MUSTBEMATCH)
('AND ('MATCHBIND VAR (LIST (CDDR (CAR PAT)))
T NIL)
('SETQ←SIDE←EFFECT
(CADR (CAR PAT))
VAR ORSETQFLG)))
[(OR (ARB? (CDDAR PAT))
(AND (NOT (ELT? (CDDAR PAT)))
(HELP
"I'LL TRY TO DO THIS MATCH IF YOU RETURN T" PAT)
))
(* To match var against (x←seg ...), match against
(seg !tem← ...), and then set x to
(LDIFF var tem))
('AND
('AND
('MATCHBIND
VAR
(CONS (CDDAR PAT)
(CONS (CONS (QUOTE !←)
(SETQ TEM (MAKEVAR T)))
(CDR PAT)))
T NIL)
TEM)
('SETQ←SIDE←EFFECT
(CADAR PAT)
('LDIFF (COPY VAR)
TEM)
(AND ORSETQFLG (CANMATCHNIL (CDDAR PAT]
(T (HELP "CAN'T DO THIS ← YET" PAT]
[-> (* Only segmentreplaces
get here -
similar to ←)
(COND
[(NULL (CDR PAT))
('AND ('MATCHBIND VAR (LIST (CDDR (CAR PAT)))
T NIL)
('REPLACE←SIDE←EFFECT
VAR
(CADR (CAR PAT]
[[OR (ARB? (CDDAR PAT))
(NOT (ELT? (CDDAR PAT]
(* To match var against (seg←x ...), match against
(seg !tem← ...), and then replace var with
(NCONC/APPEND x tem))
('AND ('MATCHBIND
VAR
(CONS (CDDAR PAT)
(CONS (CONS (QUOTE !←)
(SETQ TEM (MAKEVAR
T)))
(CDR PAT)))
T NIL)
('REPLACE←SIDE←EFFECT
('LDIFF (COPY VAR)
TEM)
(CADAR PAT]
(T (HELP "CAN'T DO THIS REPLACE YET" PAT]
(ANY (* Segment any's go
here)
(HELP (QUOTE "CAN'T DO AN ANY WHEN ")
(QUOTE "SOME ARE SEGMENTS")))
[!
(COND
((NULL (CDR PAT))
(* To MATCH VAR against (!pat) is the same as
matching it against PAT)
('MATCHELT VAR (CDR (CAR PAT))
MUSTBEMATCH))
[(SUBPAT? (CDAR PAT))
(* (..1.. ! (..2..) ..3..) is the same as
(..1.. ..2.. ..3..))
('MATCH VAR (NCONC (CDAR PAT)
(CDR PAT]
((EQ (CADAR PAT)
(QUOTE =))
('MATCHEXP ('HEADP (CDDAR PAT)
VAR)
(CDR PAT)))
((EQ (CADAR PAT)
(QUOTE '))
('MATCHEXP ('HEADP (KWOTE (CDDAR PAT))
VAR)
(CDR PAT)))
[(EQ (CDAR PAT)
(QUOTE *))
('AND
('AND
('MATCHBIND
VAR
(CONS (QUOTE $)
(CONS (CONS (QUOTE !←)
(SETQ TEM (MAKEVAR T)))
(CDR PAT)))
T NIL)
TEM)
('RETURN ('LDIFF (COPY VAR)
TEM]
[(FMEMB (CADAR PAT)
(QUOTE (← ->)))
('MATCH VAR
(RPLACA
PAT
(CONS (CADAR PAT)
(CONS (CADDAR PAT)
(CONS (QUOTE !)
(CDDDAR PAT]
(T (HELP (QUOTE "CANT DO THIS ! YET")
PAT]
[!-> (* (... !←EXPR ...))
('AND ('MATCHBIND VAR (CDR PAT)
T NIL)
('REPLACE←SIDE←EFFECT
VAR
(CDAR PAT]
[!← (* (... !VAR← ...))
(COND
[(LOCALPATVAR (CDAR PAT))
('AND ['SETQ (CDAR PAT)
VAR
(AND ORSETQFLG (CANMATCHNIL
(CDR PAT]
('MATCH (CDAR PAT)
(CDR PAT]
(T ('AND ('MATCH VAR (CDR PAT))
('SETQ←SIDE←EFFECT
(CDAR PAT)
VAR
(AND ORSETQFLG (CANMATCHNIL
(CDR PAT]
(($$ ' = == DEFAULT)
(HELP
"SHOULDN'T GET HERE - THESE PATS HANDLED PREVIOUSLY" PAT)
)
(HELP (QUOTE "I DONT UNDERSTAND THIS PATTERN:")
PAT)))
(T (HELP (QUOTE "WHAT'S HERE")
PAT])
␈↓α('MATCHBIND␈↓↓
[LAMBDA (VAR PAT MUSTBEMATCH)
('MATCH VAR PAT])
␈↓α('MATCHELT␈↓↓
[LAMBDA (VAR PATELT MUSTBEMATCH)
(* This function matches VAR against PATELT when
PATELT is an "ELEMENT" pattern -
MUSTBEMATCH has same meaning as in MAKEMATCH)
(COND
((NLISTP PATELT)
(SELECTQ PATELT
(* ('RETURN VAR))
(($1 & ≠1)
T)
(HELP (QUOTE "BAD PATTERN ELEMENT")
PATELT)))
((NLISTP (CAR PATELT))
(SELECTQ (CAR PATELT)
(DEFAULT (HELP (QUOTE
"DEFAULT SHOULD HAVE BEEN HANDLED IN ANALPAT")
(QUOTE "RETURN NIL TO DO IT NOW"))
(MAKEDEFAULT PATELT)
('MATCHELT VAR PATELT MUSTBEMATCH))
(==('EQ VAR (CDR PATELT)))
['('EQUAL VAR (KWOTE (CDR PATELT]
(=('EQUAL VAR (CDR PATELT)))
[:(COND
((OR (NLISTP (CDR PATELT))
(EQ (CADR PATELT)
(QUOTE LAMBDA)))
(LIST (CDR PATELT)
VAR))
(T (SUBST VAR (QUOTE @)
(PROG (@)
(DWIMIFY (CDR PATELT]
[ANY ('OR (MAPCAR (CDR PATELT)
(FUNCTION (LAMBDA (PE1)
('MATCHELT VAR PE1 T]
[←('AND ('MATCHELT VAR (CDDR PATELT)
T)
('SETQ←SIDE←EFFECT
(CADR PATELT)
VAR
(AND ORSETQFLG (CANMATCHNIL (CDDR PATELT]
[-> ('AND ('MATCHELT VAR (CDDR PATELT)
T)
('REPLACE←SIDE←EFFECT
VAR
(CADR PATELT]
('MATCHSUBPAT VAR PATELT)))
(T ('MATCHSUBPAT VAR PATELT])
␈↓α('MATCHEXP␈↓↓
[LAMBDA (VAR PAT)
(* CALL THIS FUNCTION INSTEAD OF 'MATCH IF THE VAR
MIGHT NOT BE EASY TO RECOMPUTE)
('MATCHEXP1 VAR PAT (FUNCTION 'MATCH])
␈↓α('MATCHFIXED␈↓↓
[LAMBDA (VAR PAT)
(* This function is called when it is known that if
any element of VAR is non NIL, then VAR is of the
right length to MATCH PAT and so no length tests
need be performed)
(PROG (NULLCHK)
(COND
((NOT (EVERY PAT (FUNCTION CANMATCHNIL)))
('MATCHEXP VAR PAT))
(T ('MATCHEXP1 VAR PAT (FUNCTION 'MATCHNNIL])
␈↓α('MATCHSUBPAT␈↓↓
[LAMBDA (VAR PATELT)
(PROG ((NULLCHK T))
(COND
(LISTPCHK ('AND ('LISTP VAR)
('MATCH VAR PATELT)))
(T ('MATCH VAR PATELT])
␈↓α('MATCHTAIL␈↓↓
[LAMBDA (VAR PAT MUSTRETURNTAIL)
(* MUSTRETURNTAIL is on if the expression must be
the tail that matched -
If it is T then just return EXPRESSION;
otherwise, it is a variable which must be set to the
EXPRESSION)
(PROG (MATCH SETS TEM TEM1 TAIL (LEN 0))
(COND
[(EQ (CAAR PAT)
(QUOTE !←))
('SETVAR MUSTRETURNTAIL ('MATCHTAIL VAR (CDR PAT)
(CDAR PAT))
(AND ORSETQFLG (CANMATCHNIL (CDR PAT]
((EQ (CAAR PAT)
(QUOTE !->))
(COND
([NOT (FMEMB MUSTRETURNTAIL (QUOTE (NIL T]
(HELP)))
('REPLACE←SIDE←EFFECT
('MATCHTAIL VAR (CDR PAT)
T)
(CDAR PAT)))
[(NULL (SETQ TAIL (SKIP$I PAT)))
(COND
((NULL MUSTRETURNTAIL)
('NOTLESSPLENGTH VAR LEN))
(T ('SETVAR MUSTRETURNTAIL ('NLEFT VAR LEN)
ORSETQFLG]
[(AND (NOT (EQ PAT TAIL))
(COND
((NULL MUSTRETURNTAIL)
('MATCHTAIL ('NTH VAR ('PLUS 1 LEN))
TAIL))
((NULLPAT? TAIL)
('SETVAR MUSTRETURNTAIL ('NLEFT VAR LEN NIL]
((AND (EQ (CAAR PAT)
(QUOTE !))
(EQ (CADAR PAT)
(QUOTE ==))
(NOT (CDR PAT)))
('SETVAR MUSTRETURNTAIL ('TAILP (CDDAR PAT)
VAR)))
((NULL (SETQ TAIL (SKIP$ANY PAT)))
(* PAT is $ followed by
a bunch of fixed-length
items)
('MATCH&SET ('NLEFT VAR LEN)
PAT
(FUNCTION 'MATCHFIXED)
NIL MUSTRETURNTAIL))
(($? (CAR PAT)) (* Can we just ignore it
-
I.e. $ $)
('MATCHTAIL VAR (CDR PAT)
MUSTRETURNTAIL))
(('MATCHWITHMEMB VAR PAT MUSTRETURNTAIL))
((AND (NOT (NULLPAT? TAIL))
(NOT (EQ PAT TAIL))
(NOMATCHARB? (CAR TAIL)))
('MATCH&SET ('MATCHSOME VAR
(PROGN (RPLACD (NLEFT PAT 1 TAIL)
(QUOTE ($)))
PAT))
TAIL
(FUNCTION 'MATCHEXP)
(FUNCTION 'CDRLEN)
MUSTRETURNTAIL))
(T ('SETVAR MUSTRETURNTAIL ('MATCHSOME VAR PAT)
ORSETQFLG])
␈↓α('MATCHSOME␈↓↓
[LAMBDA (VAR PAT)
(PROG ((SOMEVARS (CONS (GENSYML VAR)
(CONS (GENSYML VAR)
NIL)))
(MUSTBEMATCH T))
('SOME VAR (LIST (CAR SOMEVARS)
(CADR SOMEVARS))
(DSUBST (CAR SOMEVARS)
('CAR (CADR SOMEVARS))
('MATCH (CADR SOMEVARS)
PAT])
␈↓α('MATCHWITHMEMB␈↓↓
[LAMBDA (VAR PAT MUSTRETURNTAIL)
(AND (MEMBPAT? PAT)
('MATCH&SET (EQTOMEMB ('MATCHELT VAR (CAR PAT)))
(RPLACA PAT (QUOTE $1))
(FUNCTION 'MATCHEXP)
NIL MUSTRETURNTAIL])
␈↓α('MATCHNNIL␈↓↓
[LAMBDA (VAR PAT)
('AND VAR ('MATCH VAR PAT])
␈↓α('MATCHEXP1␈↓↓
[LAMBDA (VAR PAT FN)
(COND
((EASYTORECOMPUTE VAR)
(BLKAPPLY* FN VAR PAT))
(T (PROG (EXPR (FUNNYTEM (GENSYML VAR)))
(SETQ EXPR (BLKAPPLY* FN FUNNYTEM PAT))
(COND
((OR (NULL EXPR)
(EQ EXPR T))
(SETQ EXPR FUNNYTEM)))
(SETQ EXPR (MAKESUBST FUNNYTEM VAR
(LIST EXPR POSTPONEDEFFECTS
MUSTRETURN)))
(SETQ POSTPONEDEFFECTS (CADR EXPR))
(SETQ MUSTRETURN (CADDR EXPR))
(RETURN (CAR EXPR])
␈↓α(LOCALPATVAR␈↓↓
[LAMBDA (VAR)
(PROG ((LST BINDINGS))
LP (COND
((NULL LST)
(RETURN NIL))
((OR (EQ VAR (CAR LST))
(EQ VAR (CAAR LST)))
(RETURN T)))
(SETQ LST (CDR LST))
(GO LP])
␈↓α('MATCH&SET␈↓↓
[LAMBDA (EXPR PAT MATCHFN CDRFN VARTOSET)
(COND
[VARTOSET (COND
((EQ T VARTOSET)
('AND ('SETQ (SETQ TEM (MAKEVAR T))
EXPR)
('AND (BLKAPPLY* MATCHFN
(COND
(CDRFN (BLKAPPLY* CDRFN
TEM))
(T TEM))
PAT)
TEM)))
((LOCALPATVAR (SETQ TEM (MAKEVAR VARTOSET)))
('AND ('SETQ TEM EXPR)
(BLKAPPLY* MATCHFN (COND
(CDRFN (BLKAPPLY* CDRFN TEM))
(T TEM))
PAT)))
(T [POSTPONE ('SETQ TEM (SETQ TEM (MAKEVAR T]
('AND ('SETQ TEM EXPR)
('AND (BLKAPPLY* MATCHFN
(COND
(CDRFN (BLKAPPLY* CDRFN
TEM))
(T TEM))
PAT)
TEM]
(T (BLKAPPLY* MATCHFN (COND
(CDRFN (BLKAPPLY* CDRFN EXPR))
(T EXPR))
PAT])
␈↓α('CDRLEN␈↓↓
[LAMBDA (EXPR)
('NTH EXPR ('PLUS 1 LEN])
␈↓α(POSTPONE␈↓↓
[LAMBDA (EFFECT)
(SETQ POSTPONEDEFFECTS (NCONC1 POSTPONEDEFFECTS EFFECT))
T])
␈↓α('HEADP␈↓↓
[LAMBDA (A B)
(LIST (QUOTE HEADP)
A B])
␈↓α(ABP␈↓↓
[LAMBDA (PATELT SEGEXPR)
(COND
[(NLISTP (CDR PATELT))
(SELECTQ (CDR PATELT)
(("*" *) (* !* is like result←$)
(SETQ SETS T)
(QUOTE ARB))
(($1 &) (* !$1 is the same as $)
(QUOTE ARB))
(HELP (QUOTE "FUNNY NLISTP PAT AFTER ! IN")
(CDR PATELT]
(T (SELECTQ (CAR (CDR PATELT))
[' (* !'exp matches exactly
length exp things)
(LENGTH (CDR (CDR PATELT]
((= ==) (* = exp matches
precomputable NUMBER of
things)
(SETQ MATCH T)
(* THIS ISWHAT USED TO BE HERE:
(COND (SEGEXPR ('LENGTH (CDR
(CDR PATELT)))) (T (QUOTE SEG))))
(QUOTE ARB))
(:(SETQ MATCH T)
(QUOTE ARB))
((← ->)
(SETQ SETS T)
(ABP (CDR (CDR PATELT))
SEGEXPR))
(DEFAULT (* MAKEDEFAULT actually
smashes it, so go ahead
& try it again)
(MAKEDEFAULT (CDR PATELT))
(ABP PATELT SEGEXPR))
(ANY
(* ! (any ...) matches the MAX of ANAL!PAT of the
elts of the any)
(ANALPAT (CDR (CDR PATELT))
(AND SEGEXPR (QUOTE SEGEXPR))
(FUNCTION ANAL!PAT)))
(COND
[(NOT (CDDR PATELT))
(COND
((LISTP (CADR PATELT))
(RPLNODE PATELT (CADR PATELT))
(ANALPATELT PATELT SEGEXPR))
(T (ANALPATELT (CADR PATELT)
SEGEXPR]
(T (ANALPAT (CDR PATELT])
␈↓α(RPLNODE␈↓↓
[LAMBDA (X Y)
(RPLACA (RPLACD X (CDR Y))
(CAR Y])
)
␈↓α(DEFINEQ␈↓↓
␈↓α(ANALPATELT␈↓↓
[LAMBDA (PATELT SEGEXPR)
(* Analyze PATELT , returning either -
"ELT" if PATELT matches a single element -
"SEG" if PATELT matches a segment of fixed but not
given size -
A number if PATELT matches a segment of fixed, given
size -
Or "ARB" if PATELT matches a segment of not
precomputable size)
(* Unless SEGEXPR is on, in which case, the size of
the expr is returned instead of seg)
(* Also, if the PATELT is a "SET", sets special
variable "SETS" -
If it contains a match (i.e., other than $i's or $'s
or sets involving those) it sets the special
variable "MATCH")
(COND
((NLISTP PATELT)
(SELECTQ PATELT
[($1 &)
(COND
(SEGEXPR 1)
(T (QUOTE ELT]
[("*" *)
(SETQ SETS T)
(COND
(SEGEXPR 1)
(T (QUOTE ELT]
(($ --)
(QUOTE ARB))
(HELP (QUOTE "FUNNY PAT IN ANALPATELT")
PATELT)))
(T (SELECTQ (CAR PATELT)
(! (ABP PATELT SEGEXPR))
($$ (* Either $$ NUMBER or
$$ EXPRESSION)
(OR (NUMBERP (CDR PATELT))
(AND SEGEXPR (CDR PATELT))
(QUOTE SEG)))
(DEFAULT (ANALPATELT (MAKEDEFAULT PATELT)
SEGEXPR))
[(= == ' :)
(SETQ MATCH T) (* = FOO matches an
element)
(COND
(SEGEXPR 1)
(T (QUOTE ELT]
[ANY (* It's the MAX of them
all)
(ANALPAT (CDR PATELT)
(AND SEGEXPR (QUOTE SEGEXPR]
(← (* It's a set, with the
same PROP as what's
being set)
(SETQ SETS T)
(ANALPATELT (CDDR PATELT)
SEGEXPR))
(-> (* Ditto)
(SETQ SETS T)
(ANALPATELT (CDDR PATELT)
SEGEXPR))
((!← !->)
(SETQ SETS T)
0)
(PROGN (* Got a PATELT which is
a list of pats)
(ANALPAT PATELT)
(COND
(SEGEXPR 1)
(T (QUOTE ELT])
␈↓α(ANALPAT␈↓↓
[LAMBDA (PAT FLG FN TAIL)
(* Calls either ANALPATELT or FN on the elements of
PAT (up to TAIL) and returns the MAXANAL of them -
The value of FLG determinses whether MAXANAL returns
a sum or a maximum)
(PROG (VAL)
LP (COND
((OR (EQ PAT TAIL)
(NOT PAT))
(RETURN VAL)))
(SETQ VAL (MAXANAL (BLKAPPLY (OR FN (QUOTE ANALPATELT))
(LIST (CAR PAT)))
VAL FLG))
(SETQ PAT (CDR PAT))
(GO LP])
␈↓α(MAXANAL␈↓↓
[LAMBDA (VAL1 VAL2 FLG)
(COND
((NOT VAL1)
VAL2)
((NOT VAL2)
VAL1)
((OR (EQ VAL2 (QUOTE ARB))
(EQ VAL1 (QUOTE ARB)))
(QUOTE ARB))
((OR (EQ VAL1 (QUOTE SEG))
(EQ VAL2 (QUOTE SEG)))
(QUOTE SEG))
((EQ FLG (QUOTE SEGEXPR))
('PLUS VAL1 VAL2))
(FLG (IPLUS (OR (NUMBERP VAL1)
1)
(OR (NUMBERP VAL2)
1)))
[(EQ VAL1 (QUOTE ELT))
(COND
((OR (EQ VAL2 1)
(EQ VAL2 (QUOTE ELT)))
VAL2)
(T (QUOTE SEG]
[(EQ VAL2 (QUOTE ELT))
(COND
((EQ VAL1 1)
VAL1)
(T (QUOTE SEG]
(T (QUOTE SEG])
␈↓α(ANAL!PAT␈↓↓
[LAMBDA (PAT SEGEXPR)
(COND
((NLISTP PAT)
(SELECTQ PAT
(("*" *) (* !* is like result←$)
(SETQ SETS T)
(QUOTE ARB))
(($1 &) (* !$1 is the same as $)
(QUOTE ARB))
(HELP (QUOTE "FUNNY NLISTP PAT AFTER ! IN")
PAT)))
(T (SELECTQ (CAR PAT)
(' (* !'exp matches exactly
length exp things)
(LENGTH (CDR PAT)))
((= ==) (* = exp matches
precomputable NUMBER of
things)
(SETQ MATCH T)
(* THIS ISWHAT USED TO BE HERE:
(COND (SEGEXPR ('LENGTH (CDR PAT)))
(T (QUOTE SEG))))
(QUOTE ARB))
(:(SETQ MATCH T)
(QUOTE ARB))
((← ->)
(SETQ SETS T)
(ANAL!PAT (CDDR PAT)))
(DEFAULT (* MAKEDEFAULT actually
smashes it, so go ahead
& try it again)
(MAKEDEFAULT PAT)
(ANAL!PAT PAT SEGEXPR))
(ANY
(* ! (any ...) matches the MAX of ANAL!PAT of the
elts of the any)
(ANALPAT (CDR PAT)
(AND SEGEXPR (QUOTE SEGEXPR))
(FUNCTION ANAL!PAT)))
(PROGN
(* Otherwise, there is a !
(PAT) so it's the MAX, except if there are all fixed
segs, add'em up)
(ANALPAT PAT (COND
(SEGEXPR (QUOTE SEGEXPR))
(T T))
NIL NIL)
(QUOTE ARB])
␈↓α($?␈↓↓
[LAMBDA (PATELT)
(OR (FMEMB PATELT (QUOTE ($ ≠ --)))
(AND (EQ (CAR PATELT (QUOTE !))
(FMEMB (CDR PATELT)
(QUOTE (& $1 ≠1])
␈↓α(SKIP$I␈↓↓
[LAMBDA (PAT)
(* Returns to the first TAIL of PAT which doesn't
begin with a $i or a $$foo -
Sets the variable "LEN" to the total length of
things skipped over)
(SOME PAT (FUNCTION (LAMBDA (ELT)
(COND
((FMEMB ELT (QUOTE (& $1 ≠1)))
(SETQ LEN ('PLUS 1 LEN))
NIL)
((EQ (CAR ELT)
(QUOTE $$))
(SETQ LEN ('PLUS LEN (CDR ELT)))
NIL)
(T])
␈↓α(SKIP$␈↓↓
[LAMBDA (PAT SETOK MATCHOK TAIL)
(* SCANS PAT UNTIL ONE OF THE FOLLOWING CONDITIONS
OCCURS: -
(1) TAIL IS HIT -
(2) A PATTERN ELEMENT WHICH MATCHES AN ARBITRARY
LENGTH SEGMENT IS HIT -
(3) SETOK IS NIL AND A PATTERN ELMENT INVOLVING A ←
IS HIT -
(4) MATCHOK IS NIL AND A PATTERN ELMENT INVOLVING A
"MATCH" OF ANYKIND IS HIT -
(5) THE END OF PAT IS REACHED)
(* The free variables SETS and MATCH are set to T if
a set or MATCH (respectively) are found in any of
the pattern elements passed over)
(PROG (OLDSET OLDMATCH)
LP (SETQ OLDSET SETS)
(SETQ OLDMATCH MATCH)
[COND
((OR (NULL PAT)
(EQ PAT TAIL))
(RETURN PAT))
((OR (EQ (SETQ TEM (ANALPATELT (CAR PAT)
T))
(QUOTE ARB))
(AND (NOT SETOK)
SETS)
(AND (NOT MATCHOK)
MATCH))
(SETQ SETS OLDSET)
(SETQ MATCH OLDMATCH)
(RETURN PAT))
(T (SETQ LEN ('PLUS TEM LEN]
(SETQ PAT (CDR PAT))
(GO LP])
␈↓α(SKIP$ANY␈↓↓
[LAMBDA (PAT)
(* Scans PAT until a pattern element which matches
an arbitrary length segment is hit)
(* The free variables SETS and MATCH are set to T if
a set or MATCH (respectively) are found in any of
the pattern elements passed over)
(PROG (OLDSET OLDMATCH TEM)
LP (SETQ OLDSET SETS)
(SETQ OLDMATCH MATCH)
[COND
((NULL PAT)
(RETURN PAT))
((EQ (SETQ TEM (ANALPATELT (CAR PAT)
T))
(QUOTE ARB))
(SETQ SETS OLDSET)
(SETQ MATCH OLDMATCH)
(RETURN PAT))
(T (SETQ LEN ('PLUS TEM LEN]
(SETQ PAT (CDR PAT))
(GO LP])
␈↓α(ELT?␈↓↓
[LAMBDA (PATELT)
(COND
((NLISTP PATELT)
(SELECTQ PATELT
((≠1 $1 & *)
T)
(($ ≠ --)
NIL)
(HELP (QUOTE "FUNNY PAT IN ELT?")
PATELT)))
(T (SELECTQ (CAR PATELT)
(DEFAULT (MAKEDEFAULT PATELT)
T)
((= == ' :)
T)
((-> ←)
(ELT? (CDDR PATELT)))
((!← !-> ! $$)
NIL)
T])
␈↓α(MEMBPAT?␈↓↓
[LAMBDA (PAT) (* Can a MEMB be used
for pat?)
(AND (FMEMB (CAAR PAT)
(QUOTE (' = ==)))
(PROG (SETS MATCH TEM3 (PAT2 (CDR PAT)))
(* Check if PAT ends is ($ 'foo nomatch nomatch ...
Arb-nomatch ...))
LP (COND
((NULL PAT2)
(RETURN))
((AND (OR (EQ (SETQ TEM3 (ANALPATELT (CAR PAT2)))
(QUOTE ELT))
(NUMBERP TEM3))
(NULL MATCH))
(SETQ PAT2 (CDR PAT2)))
((AND (NULL MATCH)
(EQ TEM3 (QUOTE ARB)))
(RETURN PAT2))
(T (RETURN)))
(GO LP])
␈↓α(ARB?␈↓↓
[LAMBDA (PATELT)
(EQ (ANALPATELT PATELT)
(QUOTE ARB])
␈↓α(NOMATCHARB?␈↓↓
[LAMBDA (PATELT)
(COND
((NLISTP PATELT)
($? PATELT))
(T (SELECTQ (CAR PATELT)
(! (NOMATCHELT? (CDR PATELT)))
(DEFAULT (NOMATCHARB? (MAKEDEFAULT PATELT)))
((-> ←)
(NOMATCHARB? (CDDR PATELT)))
((!← !->)
(HELP "NOMATCHARB? SHOULDNT BE GIVEN" PATELT))
NIL])
␈↓α(NOMATCHELT?␈↓↓
[LAMBDA (PAT)
(PROG (MATCH SETS)
(AND (EQ (ANAL!PAT PAT)
(QUOTE ARB))
(NOT MATCH])
␈↓α(SUBPAT?␈↓↓
[LAMBDA (PATELT)
(AND (LISTP PATELT)
(NOT (FMEMB (CAR PATELT)
(QUOTE (! $$ DEFAULT = == ' : ANY ← -> !← !->])
␈↓α(NOMATCHARBCAR?␈↓↓
[LAMBDA (PAT)
(AND PAT (OR (NOMATCHARB? (CAR PAT))
(AND (OR (EQ (CAAR PAT)
(QUOTE !->))
(EQ (CAAR PAT)
(QUOTE !←)))
(NOMATCHARBCAR? (CDR PAT])
␈↓α(NULLPAT?␈↓↓
[LAMBDA (PAT)
(OR (AND (NULL PAT)
(NOT NULLCHK))
(AND PAT (PROG ((LSTPAT PAT))
LP (COND
((NULL LSTPAT)
(RETURN T))
((NOT ($? (CAR LSTPAT)))
(RETURN NIL)))
(SETQ LSTPAT (CDR LSTPAT))
(GO LP])
␈↓α(CANMATCHNIL␈↓↓
[LAMBDA (PATELT)
(COND
((NLISTP PATELT)
T)
[(SUBPAT? PATELT)
(EVERY PATELT (FUNCTION (LAMBDA (X)
(AND (NOT (ELT? X))
(CANMATCHNIL X]
((NLISTP (CAR PATELT))
(SELECTQ (CAR PATELT)
[$$ (NOT (AND (NUMBERP (CDR PATELT))
(IGREATERP (CDR PATELT)
2]
((← ->)
(CANMATCHNIL (CDDR PATELT)))
('(NULL (CDR PATELT)))
(ANY (PROG ((LST (CDR PATELT)))
LP (COND
((NULL LST)
(RETURN))
((CANMATCHNIL (CAR LST))
(RETURN T)))
(SETQ LST (CDR LST))
(GO LP)))
(!
(* This isn't really right, but i'm too lazy to do
the analysys and will assume it can match NIL)
T)
((= ==)
T)
(($ -- ≠)
(CANMATCHNIL (CDR PATELT)))
T))
(T T])
)
␈↓α(DEFINEQ␈↓↓
␈↓α(EASYTORECOMPUTE␈↓↓
[LAMBDA (EXPR)
(* If the EXPRESSION is some cadddaars of a
variable, return that variable
(something needs to check for VARS bound IN somes
and internal forms for WHEN it can't use it for the
*'s value))
(OR (AND (NLISTP EXPR)
EXPR)
(AND (OR (GETP (CAR EXPR)
(QUOTE CROPS))
(FMEMB (CAR EXPR)
EASYFNS))
(EASYTORECOMPUTE (CADR EXPR])
␈↓α(EQTOMEMB␈↓↓
[LAMBDA (EXPR)
(LIST (SELECTQ (CAR EXPR)
(EQUAL (QUOTE MEMBER))
(EQ (QUOTE MEMB))
(HELP (QUOTE "BAD EQ EXPR IN EQTOMEMB")
EXPR))
(CADDR EXPR)
(CADR EXPR])
␈↓α(FULLEXPANSION␈↓↓
[LAMBDA (X)
(PROG [(TEM (FASSOC (CAR X)
(QUOTE ((CDDDDR CDR CDDDR)
(CADDDR CAR CDDDR)
(CDDDR CDR CDDR)
(CDADDR CDR CADDR)
(CAADDR CAR CADDR)
(CADDR CAR CDDR)
(CDDR CDR CDR)
(CDDADR CDR CDADR)
(CADADR CAR CDADR)
(CDADR CDR CADR)
(CDAADR CDR CAADR)
(CAAADR CAR CAADR)
(CAADR CAR CADR)
(CADR CAR CDR)
(CDDDAR CDR CDDAR)
(CADDAR CAR CDDAR)
(CDDAR CDR CDAR)
(CDADAR CDR CADAR)
(CAADAR CAR CADAR)
(CADAR CAR CDAR)
(CDAR CDR CAR)
(CDDAAR CDR CDAAR)
(CADAAR CAR CDAAR)
(CDAAR CDR CAAR)
(CDAAAR CDR CAAAR)
(CAAAAR CAR CAAAR)
(CAAAR CAR CAAR)
(CAAR CAR CAR]
(COND
((NULL TEM)
X)
(T (LIST (CADR TEM)
(LIST (CADDR TEM)
(CADR X])
␈↓α(GENSYML␈↓↓
[LAMBDA (X)
(OR (CAR (SETQ GENSYMVARLIST (CDR GENSYMVARLIST)))
(GENSYM])
␈↓α(MAKESUBST␈↓↓
[LAMBDA (OLD NEW EXPR)
(PROG [FOUNDBEFORE (SAVNEW NEW)
(EASYFNS (QUOTE (CAR CDR SETQ]
(MAKESUBST1 (SETQ EXPR (COPY EXPR)))
(RETURN EXPR])
␈↓α(MAKESUBST1␈↓↓
[LAMBDA (EXPR)
(COND
((NLISTP EXPR)
EXPR)
((EQ (CAR EXPR) OLD)
(COND
((NOT FOUNDBEFORE)
(SETQ FOUNDBEFORE EXPR))
((NLISTP FOUNDBEFORE))
((EASYTORECOMPUTE NEW)
(SETQ NEW (RECOMPUTATION NEW))
(SETQ FOUNDBEFORE (QUOTE RECOMPUTED)))
(T (RPLACA FOUNDBEFORE ('SETQ (SETQ NEW (GENSYML OLD))
SAVNEW))
(SETQ FOUNDBEFORE T)
(BIND NEW)))
(RPLACA EXPR NEW)
(MAKESUBST1 (CDR EXPR)))
(T (MAKESUBST1 (CAR EXPR))
(MAKESUBST1 (CDR EXPR])
␈↓α(FORMEXPAND␈↓↓
[LAMBDA (LIST AT)
(* Searches for (AT --) AT the top level of list and
does a (1) up (bo 1) on them)
[MAP LIST (FUNCTION (LAMBDA (X)
(AND (EQ (CAR (CAR X))
AT)
(RPLACD X (NCONC (CDDR (CAR X))
(CDR X)))
(RPLACA X (CADR (CAR X]
LIST])
␈↓α(BIND␈↓↓
[LAMBDA (VAR)
(SETQ BINDINGS (CONS VAR BINDINGS])
␈↓α(BOUNDVAR␈↓↓
[LAMBDA (X)
(AND X (NOT (FMEMB X SOMEVARS])
␈↓α(RECOMPUTATION␈↓↓
[LAMBDA (EXPR)
(COND
((NLISTP EXPR)
EXPR)
[[OR (GETP (CAR EXPR)
(QUOTE CROPS))
(FMEMB (CAR EXPR)
(QUOTE (CAR CDR]
(LIST (CAR EXPR)
(EASYTORECOMPUTE (CADR EXPR]
((EQ (CAR EXPR)
(QUOTE SETQ))
(CADR EXPR))
(T (HELP "CANT RECOMPUTE"])
␈↓α(MAKEVAR␈↓↓
[LAMBDA (X)
(COND
((EQ X T)
(BIND (SETQ X (GENSYML X)))
X)
(T X])
)
␈↓α(DEFINEQ␈↓↓
␈↓α('NLEFT␈↓↓
[LAMBDA (EXPR N TAIL)
(COND
(TAIL (LIST (QUOTE NLEFT)
EXPR N TAIL))
((EQ N 0)
('CDR ('LAST EXPR)))
((EQ N 1)
('LAST EXPR))
(T (LIST (QUOTE NLEFT)
EXPR N])
␈↓α('NOT␈↓↓
[LAMBDA (X)
(COND
((FMEMB (CAR X)
(QUOTE (NOT NULL)))
(CADR X))
(T (LIST (QUOTE NOT)
X])
␈↓α('NOTLESSPLENGTH␈↓↓
[LAMBDA (X N)
(COND
((ZEROP N)
T)
(T ('NTH X N])
␈↓α('NTH␈↓↓
[LAMBDA (VAR LEN)
(COND
((NOT (NUMBERP LEN))
(LIST (QUOTE NTH)
VAR LEN))
(T ('NTH{NUMBER⎇ VAR LEN])
␈↓α('NTH{NUMBER⎇␈↓↓
[LAMBDA (VAR LEN)
(COND
((EQ LEN 1)
VAR)
((EQ LEN 2)
(LIST (QUOTE CDR)
VAR))
((EQ LEN 3)
(LIST (QUOTE CDDR)
VAR))
((EQ LEN 4)
(LIST (QUOTE CDDDR)
VAR))
((EQ LEN 5)
(LIST (QUOTE CDDDDR)
VAR))
(T ('NTH{NUMBER⎇ (LIST (QUOTE CDDDDR)
VAR)
(IDIFFERENCE LEN 4])
␈↓α('OR␈↓↓
[LAMBDA (EXPRLIST)
(CONS (QUOTE OR)
(FORMEXPAND EXPRLIST (QUOTE OR])
␈↓α('PLUS␈↓↓
[LAMBDA (EXPR1 EXPR2)
(COND
((AND (NUMBERP EXPR1)
(NUMBERP EXPR2))
(IPLUS EXPR1 EXPR2))
((AND (NUMBERP EXPR1)
(NUMBERP EXPR2))
(IPLUS EXPR1 EXPR2))
(T (PROG ((SUM 0)
(LST (FORMEXPAND (LIST EXPR1 EXPR2)
(QUOTE IPLUS)))
VAL)
[MAPC LST (FUNCTION (LAMBDA (X)
(COND
((NUMBERP X)
(SETQ SUM (IPLUS X SUM)))
(T (SETQ VAL (NCONC1 VAL X]
(COND
((NULL VAL)
SUM)
((IGREATERP SUM 0)
(CONS (QUOTE IPLUS)
(CONS SUM VAL)))
((NULL (CDR VAL))
(CAR VAL))
(T (CONS (QUOTE IPLUS)
VAL])
␈↓α('REPLACE␈↓↓
[LAMBDA (VAR EXPR)
(SETQ VAR (FULLEXPANSION VAR))
(COND
((EQ (CAR VAR)
(QUOTE CAR))
(LIST (QUOTE RPLACA)
(CADR VAR)
EXPR))
((EQ (CAR VAR)
(QUOTE CDR))
(LIST (QUOTE RPLACD)
(CADR VAR)
EXPR))
[(EQ (CAR VAR)
(QUOTE LDIFF))
('REPLACE (CADR VAR)
(LIST (QUOTE NCONC)
EXPR
(CADDR VAR]
(T (LIST (QUOTE RPLNODE)
VAR EXPR])
␈↓α('SETQ←SIDE←EFFECT␈↓↓
[LAMBDA (VAR VALUE LOCALORSETQFLG)
(COND
((OR (NOT POSTPONE←SIDE←EFFECTS)
(LOCALPATVAR VAR))
('SETQ VAR VALUE (AND MUSTBEMATCH LOCALORSETQFLG)))
(T (POSTPONE ('SETQ VAR VALUE))
T])
␈↓α('REPLACE←SIDE←EFFECT␈↓↓
[LAMBDA (VAR VALUE)
(COND
[POSTPONE←SIDE←EFFECTS
(COND
[(SETQ TEM (EASYTORECOMPUTE VAR))
(COND
((BOUNDVAR TEM)
(POSTPONE ('REPLACE VAR VALUE))
T)
(T (POSTPONE ('REPLACE (SUBST (SETQ TEM2 (MAKEVAR T))
TEM VAR)
VALUE))
('SETQ TEM2 TEM]
(T (PROG (TEM2 (TEM ('REPLACE VAR VALUE)))
(PROG1 ('SETQ (SETQ TEM2 (MAKEVAR T))
(CADR TEM))
(RPLACA (CDR TEM)
TEM2)
(POSTPONE TEM]
(T ('REPLACE VAR VALUE])
␈↓α('SETQ␈↓↓
[LAMBDA (VAR EXPRESSION 'SETQ-ORSETQFLG)
(COND
([NOT (AND VAR (LITATOM VAR)
(NOT (EQ VAR T]
(HELP (QUOTE "TRYING TO SET NON-VARIABLE")
VAR)))
(SETQ EXPRESSION (LIST (QUOTE SETQ)
VAR EXPRESSION))
(COND
('SETQ-ORSETQFLG (LIST (QUOTE OR)
EXPRESSION T))
(T EXPRESSION])
␈↓α('SETVAR␈↓↓
[LAMBDA (VAR EXPR LOCALORSETQFLG)
(COND
[(AND VAR (NOT (EQ VAR T)))
(COND
((AND POSTPONE←SIDE←EFFECTS
(LOCALPATVAR VAR))
('SETQ VAR EXPR LOCALORSETQFLG))
((EASYTORECOMPUTE EXPR)
(POSTPONE ('SETQ VAR EXPR))
EXPR)
(T (PROG (TEM)
[POSTPONE ('SETQ VAR (SETQ TEM (MAKEVAR T]
('SETQ TEM EXPR LOCALORSETQFLG]
(T EXPR])
␈↓α('SOME␈↓↓
[LAMBDA (LST ARGS EXPR)
(LIST (QUOTE SOME)
LST
(LIST (QUOTE FUNCTION)
(LIST (QUOTE LAMBDA)
ARGS EXPR])
␈↓α('AND␈↓↓
[LAMBDA (EXPR1 EXPR2)
(PROG (TEM)
(COND
((EQ EXPR1 T)
EXPR2)
((EQ EXPR2 T)
EXPR1)
[(AND [OR (AND (EQ (CAR EXPR1)
(QUOTE SETQ))
(SETQ TEM EXPR1))
(AND (EQ (CAR EXPR1)
(QUOTE OR))
(EQ (CAADR EXPR1)
(QUOTE SETQ))
(EQ (CADDR EXPR1)
T)
(SETQ TEM (CADR EXPR1]
(COND
((EQ EXPR2 (CADR TEM))
TEM)
((AND (EQ (CAR EXPR2)
(QUOTE AND))
(EQ (CADR TEM)
(CADR EXPR2)))
(RPLACA (CDR EXPR2)
TEM)
EXPR2]
((EQUAL EXPR1 EXPR2)
EXPR2)
((EQ (CAR EXPR1)
(QUOTE PROGN))
(SETQ TEM (LAST EXPR1))
(RPLACA TEM ('AND (CAR TEM)
EXPR2))
EXPR1)
((AND (EQ (CAR EXPR2)
(QUOTE COND))
(NOT (CDDR EXPR2)))
(RPLACA (CADR EXPR2)
('AND EXPR1 (CAADR EXPR2)))
EXPR2)
((EQ (CAR EXPR1)
(QUOTE COND))
(PROG (TEM)
(SETQ TEM (LAST (CADR EXPR1)))
(RPLACA TEM ('AND (CAR TEM)
EXPR2))
(RETURN EXPR1)))
((AND (EQ (CAR EXPR2)
(QUOTE OR))
(EQ (CADDR EXPR2)
T))
(LIST (QUOTE COND)
(LIST EXPR1 (CADR EXPR2)
T)))
[(EQ (CAR EXPR2)
(QUOTE PROGN))
(LIST (QUOTE COND)
(CONS EXPR1 (CDR EXPR2]
[(EQ (CAR EXPR2)
(QUOTE AND))
(COND
((EQ (CAR EXPR1)
(QUOTE AND))
(NCONC EXPR1 (CDR EXPR2)))
(T (RPLACD EXPR2 (CONS EXPR1 (CDR EXPR2]
((EQ (CAR EXPR1)
(QUOTE AND))
(NCONC1 EXPR1 EXPR2))
(T (LIST (QUOTE AND)
EXPR1 EXPR2])
␈↓α('!AND␈↓↓
[LAMBDA (EXPRLIST)
(OPTIMIZEAND (CONS (QUOTE AND)
EXPRLIST])
␈↓α(OPTIMIZEAND␈↓↓
[LAMBDA (EXPRESSION)
(* NOTE: NEEDS TO BE ADDED -
('AND $ !X← ('OR & 'T) $ !Y←}
('OR & T) $) -
-
GOES TO -
-
<'COND < (LDIFF VAR X) ! (MAPCAR
(LDIFF X Y) 'CADR) <'AND !Y>>>)
(PROG ((LIS EXPRESSION))
LP (COND
[(NULL (CDR LIS))
(RETURN (COND
((CDDR EXPRESSION)
EXPRESSION)
(T (CADR EXPRESSION]
((OR (NULL (CADR LIS))
(EQ (CADR LIS)
T))
(RPLACD LIS (CDDR LIS)))
[(NLISTP (CADR LIS))
(RPLACD (CDR LIS)
(DREMOVE (CADR LIS)
(CDDR LIS]
((EQ (CAADR LIS)
(QUOTE SETQ))
(DREMOVE (CADADR LIS)
(CDR LIS)))
((EQ (CAADR LIS)
(QUOTE AND))
(RPLACD LIS (NCONC (CDADR LIS)
(CDDR LIS)))
(GO LP)))
(SETQ LIS (CDR LIS))
(GO LP])
␈↓α('CAR␈↓↓
[LAMBDA (X)
(PROG [(TEM (FASSOC (CAR X)
(QUOTE ((CAR . CAAR)
(CDR . CADR)
(CAAR . CAAAR)
(CADR . CAADR)
(CDAR . CADAR)
(CDDR . CADDR)
(CAAAR . CAAAAR)
(CAADR . CAAADR)
(CADAR . CAADAR)
(CADDR . CAADDR)
(CDAAR . CADAAR)
(CDADR . CADADR)
(CDDAR . CADDAR)
(CDDDR . CADDDR]
(COND
(TEM (LIST (CDR TEM)
(CADR X)))
(T (LIST (QUOTE CAR)
X])
␈↓α('CDR␈↓↓
[LAMBDA (X)
(PROG [(TEM (FASSOC (CAR X)
(QUOTE ((CAR . CDAR)
(CDR . CDDR)
(CAAR . CDAAR)
(CADR . CDADR)
(CDAR . CDDAR)
(CDDR . CDDDR)
(CAAAR . CDAAAR)
(CAADR . CDAADR)
(CADAR . CDADAR)
(CADDR . CDADDR)
(CDAAR . CDDAAR)
(CDADR . CDDADR)
(CDDAR . CDDDAR)
(CDDDR . CDDDDR]
(COND
(TEM (LIST (CDR TEM)
(CADR X)))
(T (LIST (QUOTE CDR)
X])
␈↓α('EQ␈↓↓
[LAMBDA (VAR EXPRESSION)
(COND
((NULL EXPRESSION)
('NULL VAR))
(T (LIST (QUOTE EQ)
VAR EXPRESSION])
␈↓α('EQLENGTH␈↓↓
[LAMBDA (VAR LEN)
(COND
((NOT NULLCHK)
T)
((ZEROP LEN)
('NOT VAR))
[(EQ LEN 1)
('AND VAR ('NOT ('CDR VAR]
[(AND (NUMBERP LEN)
(ILESSP LEN 5))
('AND (SETQ VAR ('NTH VAR LEN))
('NULL ('CDR VAR]
(T ('EQ ('LENGTH VAR)
LEN])
␈↓α('EQUAL␈↓↓
[LAMBDA (VAR EXPRESSION)
(COND
((NULL EXPRESSION)
('NOT VAR))
(T (LIST (COND
([OR (SMALLP EXPRESSION)
(AND (EQ (CAR EXPRESSION)
(QUOTE QUOTE))
(OR (SMALLP (CADR EXPRESSION))
(LITATOM (CADR EXPRESSION]
(QUOTE EQ))
((NUMBERP EXPRESSION)
(QUOTE EQP))
(T (QUOTE EQUAL)))
VAR EXPRESSION])
␈↓α('LENGTH␈↓↓
[LAMBDA (EXPR)
(LIST (QUOTE LENGTH)
EXPR])
␈↓α('LISTP␈↓↓
[LAMBDA (X)
(LIST (QUOTE LISTP)
X])
␈↓α('NULL␈↓↓
[LAMBDA (X)
(COND
((FMEMB (CAR X)
(QUOTE (NOT NULL)))
(CADR X))
(T (LIST (QUOTE NULL)
X])
␈↓α('LAST␈↓↓
[LAMBDA (X)
(LIST (QUOTE LAST)
X])
␈↓α('TAILP␈↓↓
[LAMBDA (X Y)
(LIST (QUOTE TAILP)
X Y])
␈↓α('LDIFF␈↓↓
[LAMBDA (A B)
(LIST (QUOTE LDIFF)
A B])
␈↓α('RETURN␈↓↓
[LAMBDA (VALUE)
(COND
((AND (NOT MUSTBEMATCH)
(NULL POSTPONEDEFFECTS))
VALUE)
((BOUNDVAR (PROG [(EASYFNS (QUOTE (CAR CDR SETQ]
(EASYTORECOMPUTE VALUE)))
(SETQ MUSTRETURN (RECOMPUTATION VALUE))
T)
(T (BIND (SETQ MUSTRETURN (GENSYML VALUE)))
('SETQ MUSTRETURN VALUE ORSETQFLG])
)
␈↓α(DEFINEQ␈↓↓
␈↓α(PARSE␈↓↓
[LAMBDA (X)
(PATPARSE (COPY X])
␈↓α(PATPARSE␈↓↓
[LAMBDA (PAT)
(PROG (NUMLIST)
(* NUMLIST is a list of the #'s that have been found
-
For every # that is found, an entry is added to
NUMLIST which is (NUMBER %. Pattern where the NUMBER
occured) so that later, NUMPATPARSE can go back and
change the numbered item to
(← (## . I) item) and thus, the thing can be saved.
In MAKEMATCH, the thing-that-matched item will
either be bound to a variable, or passed along)
(SETQ PAT (PATPARSE1 PAT))
(COND
(NUMLIST (NUMPATPARSE NUMLIST)))
(RETURN PAT])
␈↓α(NUMPATPARSE␈↓↓
[LAMBDA (PAT NUMLIST)
(OR (NOT NUMLIST)
(HELP (QUOTE "NUMBERS NOT DONE YET")
PAT])
␈↓α(PATPARSE1␈↓↓
[LAMBDA (PAT BACKPAT)
(* Smashes PAT with it's parsing;
BACKPAT is used when there is a ← to determine if
the previous thing was a !, a variable, or a pattern
-
If it was VAR or !, leave it alone -
If it was a pattern, then don't PATPARSE the next
thing, since it's an EXPRESSION -
In the first two cases, BACKPAT should be T;
otherwise, it should be the previous thing)
(AND PAT
(PROG (TEM)
RETRY
[COND
[(NLISTP (CAR PAT))
(SELECTQ (CAR PAT)
((= == : $$)
(* Look for ←'s in (CADR PAT) and spread it out if
so -
This might want to change later -
(= foo←fie ...) -
(=foo ←fie ...) -
(=foo←fie ...) -
The second case is not ambiguous, but the first is -
it's possible to handle it just like the QUOTE -
Never split -
Or leave it to PATPARSEAT never to split after an
equal -
Also, need it for the (admittedly rare) case of #
1←foo)
(PATPARSE← (CDR PAT))
(* And then "BI" CAR &
CDR PAT)
(BI12 PAT))
[$ (PATPARSE← (CDR PAT))
(COND
((EQ (CADR PAT)
(QUOTE 1))
(RPLACA PAT (QUOTE $1))
(RPLACD PAT (CDDR PAT)))
((SMALLP (CADR PAT))
(BI12 PAT)
(RPLACA (CAR PAT)
(QUOTE $$]
(' (* NO ←'S ALLOWED OR
CHECKED FOR)
(BI12 PAT))
(%. (RPLACA PAT (QUOTE !)))
((& $1 ≠1 * ! --)
(* These are all ok -
! will be handled later)
T)
[←(COND
((NOT BACKPAT)
(PATPARSE1 (CDDR PAT))
(RETURN PAT]
(COND
[(STRINGP (CAR PAT))
(RPLACA PAT (CONS (QUOTE ')
(MKATOM (CAR PAT]
((AND (STRPOSL (QUOTE (! ' ≠ & - # ← = $
:))
(CAR PAT)
1)
(PATPARSEAT (DUNPACK (CAR PAT)
SKORLST2)
PAT))
(* Otherwise, BREAK up
CAR PAT and try to
PATPARSEAT it)
(GO RETRY))
(T (* Must have a variable
here!)
(SETQ TEM (QUOTE VAR]
((EQ (CAAR PAT)
(QUOTE ANY))
(PATPARSE1 (CDAR PAT)))
(T (* Otherwise, all there
is is a subpattern)
(PATPARSE1 (CAR PAT]
[AND (CDR PAT)
(NLISTP (CDR PAT))
(RPLACD PAT (LIST (QUOTE !)
(CDR PAT]
(PATPARSE1 (CDR PAT)
TEM)
[COND
[(EQ (CADR PAT)
(QUOTE ←))
(COND
((EQ (CAR PAT)
(QUOTE !)) (* Got (!←expr ...)
change it to
((! ← . expr) ...))
(RPLACD PAT (CDDR PAT))
(RPLACA PAT (QUOTE !->))
(BI12 PAT))
[(EQ TEM (QUOTE VAR))
(* Got (VAR ← PAT ...); change it to
((← VAR . PAT) ...))
(COND
((CDDR PAT)
(BISET PAT))
(T (HELP "NOTHING AFTER A '←' IN A PATTERN"
TOPPAT]
(T
(* Otherwise, there is a (PAT ← EXPR ...); change it
to (-> expr . PAT))
(BIRPLAC PAT]
[(EQ (CAR PAT)
(QUOTE !))
(COND
((EQ (CAADR PAT)
(QUOTE DEFAULT))
(MAKE!DEFAULT PAT))
[(EQ (CAADR PAT)
(QUOTE ←))
[RPLACA PAT (CONS (QUOTE !←)
(CADR (CADR PAT]
(RPLACA (CDR PAT)
(CDDR (CADR PAT]
(T (BI12 PAT]
((EQ TEM (QUOTE VAR))
(RPLACA PAT (CONS (QUOTE DEFAULT)
(CAR PAT]
(RETURN PAT])
␈↓α(PATPARSE←␈↓↓
[LAMBDA (PAT) (* Look for ←'s in
(CAR PAT))
(AND (LITATOM (CAR PAT))
(PATPARSEAT (DUNPACK (CAR PAT)
SKORLST2)
PAT
(QUOTE (←])
␈↓α(BI12␈↓↓
[LAMBDA (PAT) (* This changes
(A B ...) to
((A . B) ...))
(COND
((OR (NLISTP PAT)
(NLISTP (CDR PAT)))
(ERROR "BAD ARG TO BI12" PAT)))
(PROG ((TEM (CDR PAT)))
(RPLACD PAT (CDDR PAT))
(RPLACD TEM (CAR TEM))
(RPLACA TEM (CAR PAT))
(RPLACA PAT TEM])
␈↓α(PATPARSEAT␈↓↓
[LAMBDA (UNPACKEDAT PAT FLG)
(* Parses (CAR PAT) which has been unpacked into
UNPACKEDAT and replaces the parsing into
(CAR PAT); otherwise return if can't -
Unless flg is on, meaning always smash
(CAR PAT))
(PROG (TAIL AT REST)
(RETURN (COND
([SETQ TAIL
(SOME UNPACKEDAT
(FUNCTION (LAMBDA (CHR)
(FMEMB CHR
(QUOTE (' = ← * $ # %.
! ' :]
(SETQ AT (CAR TAIL))
[SETQ REST (COND
((AND (EQ (CAR TAIL)
(QUOTE =))
(EQ (CADR TAIL)
(QUOTE =)))
(SETQ AT (QUOTE ==))
(CDDR TAIL))
([AND (EQ (CAR TAIL)
(QUOTE $))
(EQ (CADR TAIL)
1)
(NOT (SMALLP (CADDR TAIL]
(* $1's are parsed as an
atom)
(SETQ AT (QUOTE $1))
(CDDR TAIL))
((AND (EQ (CAR TAIL)
(QUOTE $))
(EQ (CADR TAIL)
(QUOTE $)))
(SETQ AT (QUOTE $$))
(CDDR TAIL))
(T (CDR TAIL]
(COND
(REST (PATPARSEAT REST PAT T)
(ATTACH AT PAT))
(T (RPLACA PAT AT)))
(AND (NOT (EQ TAIL UNPACKEDAT))
(ATTACH (PACKLDIFF UNPACKEDAT TAIL)
PAT))
PAT)
(FLG (RPLACA PAT (PACK UNPACKEDAT])
␈↓α(PACKLDIFF␈↓↓
[LAMBDA (L TAIL)
(PROG (TEM)
(AND (SETQ TEM (NLEFT L 1 TAIL))
(RPLACD TEM)
(PROG1 (PACK L)
(RPLACD TEM TAIL])
␈↓α(BISET␈↓↓
[LAMBDA (PAT)
(* This function changes (a b c ...) to
((b a . c) ...))
(PROG ((TEM (CDR PAT)))
(RPLACD PAT (CDDDR PAT))
(RPLACD (CDR TEM)
(CADR TEM))
(RPLACA (CDR TEM)
(CAR PAT))
(RPLACA PAT TEM])
␈↓α(BIRPLAC␈↓↓
[LAMBDA (PAT)
(PROG ((TEM (CAR PAT)))
(RPLACA PAT (CDR PAT))
(RPLACD PAT (CDDDR PAT))
(RPLACD (CDAR PAT)
TEM)
(RPLACA (CAR PAT)
(QUOTE ->])
␈↓α(MAKEDEFAULT␈↓↓
[LAMBDA (PATELT)
(* Turns PATELT (which is either NLISTP, or
(default . atom), into the "DEFAULT" pattern -
I.e. PATELT couldn't be parsed as a pattern -
It is assumed that the default for an atom is an
element pattern))
(COND
[(EQ (CAR PATELT)
(QUOTE DEFAULT))
(SELECTQ VARDEFAULT
[(← SETQ SET)
(COND
([OR (FMEMB (CDR PATELT)
(QUOTE (NIL T)))
(NOT (LITATOM (CDR PATELT]
(FRPLACA PATELT (QUOTE ')))
(T (FRPLACA (FRPLACD PATELT (CONS (CDR PATELT)
(QUOTE $1)))
(QUOTE ←]
((QUOTE ')
(FRPLACA PATELT (QUOTE ')))
((= EQUAL)
(FRPLACA PATELT (QUOTE =)))
(HELP (QUOTE "FUNNY VARDEFAULT"]
(T (SELECTQ VARDEFAULT
[(← SETQ SET)
(CONS (QUOTE ←)
(CONS PATELT (QUOTE $1]
((QUOTE ')
(CONS (QUOTE ')
PATELT))
((= EQUAL)
(CONS (QUOTE =)
PATELT))
(HELP (QUOTE "FUNNY VARDEFAULT"])
␈↓α(MAKE!DEFAULT␈↓↓
[LAMBDA (PAT)
(SELECTQ VARDEFAULT
((← SETQ SET)
[FRPLACA PAT (CONS (QUOTE ←)
(CONS (CDR (CADR PAT))
(QUOTE $]
(FRPLACD PAT (CDDR PAT)))
((QUOTE ')
(FRPLACA (CADR PAT)
(QUOTE '))
(BI12 PAT))
((= EQUAL)
(FRPLACA (CADR PAT)
(QUOTE =))
(BI12 PAT))
(HELP (QUOTE "FUNNY VARDEFAULT"])
)
␈↓α(DEFINEQ␈↓↓
␈↓α(HEADP␈↓↓
[LAMBDA (A B)
(PROG NIL
LP (COND
((NULL A)
(RETURN (OR B T)))
((NLISTP A)
(RETURN (EQ A B)))
([OR (NLISTP B)
(NOT (EQUAL (CAR A)
(CAR B]
(RETURN NIL)))
(SETQ A (CDR A))
(SETQ B (CDR B))
(GO LP])
)
(RPAQQ POSTPONE←SIDE←EFFECTS T)
(RPAQQ VARDEFAULT SET)
(RPAQQ LISTPCHK NIL)
(RPAQQ ORSETQFLG T)
[RPAQQ MATCHBLOCKS
((MATCHBLOCK MAKEMATCH 'MATCHTOP 'MATCH 'MATCHBIND 'MATCHELT
'MATCHEXP 'MATCHFIXED 'MATCHSUBPAT 'MATCHTAIL
'MATCHSOME 'MATCHWITHMEMB 'MATCHNNIL 'MATCHEXP1
LOCALPATVAR 'MATCH&SET 'CDRLEN POSTPONE
NOMATCHELT? 'HEADP ANALPATELT ANALPAT MAXANAL
ANAL!PAT ABP $? SKIP$I SKIP$ SKIP$ANY ELT?
MEMBPAT? ARB? NOMATCHARB? SUBPAT? NOMATCHARBCAR?
NULLPAT? CANMATCHNIL EASYTORECOMPUTE EQTOMEMB
FULLEXPANSION GENSYML MAKESUBST MAKESUBST1
FORMEXPAND BIND BOUNDVAR RECOMPUTATION MAKEVAR
'NLEFT 'NOT 'NOTLESSPLENGTH 'NTH 'NTH{NUMBER⎇ 'OR
'PLUS 'REPLACE 'SETQ←SIDE←EFFECT
'REPLACE←SIDE←EFFECT 'SETQ 'SETVAR 'SOME 'AND
'!AND OPTIMIZEAND 'CAR 'CDR 'EQ 'EQLENGTH 'EQUAL
'LENGTH 'LISTP 'NULL 'LAST 'TAILP 'LDIFF 'RETURN
PARSE PATPARSE NUMPATPARSE PATPARSE1 PATPARSE←
BI12 PATPARSEAT PACKLDIFF BISET BIRPLAC
MAKEDEFAULT MAKE!DEFAULT
(BLKAPPLYFNS ANALPATELT ANAL!PAT 'MATCH
'MATCHNNIL 'MATCHFIXED 'MATCHEXP
'CDRLEN)
(ENTRIES MAKEMATCH)
(GLOBALVARS VARDEFAULT LISTPCHK ORSETQFLG
POSTPONE←SIDE←EFFECTS)
(LOCALFREEVARS TAIL TEM ISVALUE EASYFNS BINDINGS
MUSTBEMATCH POSTPONEDEFFECTS
MUSTRETURN SOMEVARS GENSYMVARSLIST
MAKESUBSTVARLIST MATCH SETS
NULLCHK TOPPAT FOUNDBEFORE LEN
GENSYMVARLIST OLD NEW SAVNEW TEM2]
␈↓α(DECLARE␈↓↓
(BLOCK: MATCHBLOCK MAKEMATCH 'MATCHTOP 'MATCH 'MATCHBIND 'MATCHELT
'MATCHEXP 'MATCHFIXED 'MATCHSUBPAT 'MATCHTAIL 'MATCHSOME
'MATCHWITHMEMB 'MATCHNNIL 'MATCHEXP1 LOCALPATVAR 'MATCH&SET
'CDRLEN POSTPONE NOMATCHELT? 'HEADP ANALPATELT ANALPAT
MAXANAL ANAL!PAT ABP $? SKIP$I SKIP$ SKIP$ANY ELT? MEMBPAT?
ARB? NOMATCHARB? SUBPAT? NOMATCHARBCAR? NULLPAT? CANMATCHNIL
EASYTORECOMPUTE EQTOMEMB FULLEXPANSION GENSYML MAKESUBST
MAKESUBST1 FORMEXPAND BIND BOUNDVAR RECOMPUTATION MAKEVAR
'NLEFT 'NOT 'NOTLESSPLENGTH 'NTH 'NTH{NUMBER⎇ 'OR 'PLUS
'REPLACE 'SETQ←SIDE←EFFECT 'REPLACE←SIDE←EFFECT 'SETQ 'SETVAR
'SOME 'AND '!AND OPTIMIZEAND 'CAR 'CDR 'EQ 'EQLENGTH 'EQUAL
'LENGTH 'LISTP 'NULL 'LAST 'TAILP 'LDIFF 'RETURN PARSE
PATPARSE NUMPATPARSE PATPARSE1 PATPARSE← BI12 PATPARSEAT
PACKLDIFF BISET BIRPLAC MAKEDEFAULT MAKE!DEFAULT
(BLKAPPLYFNS ANALPATELT ANAL!PAT 'MATCH 'MATCHNNIL
'MATCHFIXED 'MATCHEXP 'CDRLEN)
(ENTRIES MAKEMATCH)
(GLOBALVARS VARDEFAULT LISTPCHK ORSETQFLG
POSTPONE←SIDE←EFFECTS)
(LOCALFREEVARS TAIL TEM ISVALUE EASYFNS BINDINGS MUSTBEMATCH
POSTPONEDEFFECTS MUSTRETURN SOMEVARS
GENSYMVARSLIST MAKESUBSTVARLIST MATCH SETS
NULLCHK TOPPAT FOUNDBEFORE LEN GENSYMVARLIST
OLD NEW SAVNEW TEM2))
)(DEFLIST(QUOTE(
[EVERY
(X
(PROG
(LL Q)
(RETURN
(SUBPAIR
(QUOTE (MAPX MAPCF MAPCF2 B))
(LIST
(CAR X)
[COND [(SETQ Q (CFNP (CADR X)))
(CONS Q (QUOTE ((CAR MACROX)
MACROX]
(T [SETQ LL (CONS (LIST (QUOTE MACROF)
(CADR X]
(QUOTE (APPLY* MACROF (CAR MACROX)
MACROX]
[COND
[(CDDR X)
(COND
[(SETQ Q (CFNP (CADDR X)))
(CONS Q (QUOTE (MACROX]
(T (SETQ LL
(CONS [LIST (QUOTE MACROF2)
(LIST (QUOTE OR)
(CADDR X)
(QUOTE (QUOTE CDR]
LL))
(QUOTE (APPLY* MACROF2 MACROX]
(T (QUOTE (CDR MACROX]
LL)
(QUOTE (PROG ((MACROX MAPX) . B)
MAPCLP
(COND ((NLISTP MACROX)
(RETURN T))
((NOT MAPCF)
(RETURN NIL)))
(SETQ MACROX MAPCF2)
(GO MAPCLP]
[SOME
(X
(PROG
(LL Q)
(RETURN
(SUBPAIR
(QUOTE (MAPX MAPCF MAPCF2 B))
(LIST
(CAR X)
[COND [(SETQ Q (CFNP (CADR X)))
(CONS Q (QUOTE ((CAR MACROX)
MACROX]
(T [SETQ LL (CONS (LIST (QUOTE MACROF)
(CADR X]
(QUOTE (APPLY* MACROF (CAR MACROX)
MACROX]
[COND
[(CDDR X)
(COND
[(SETQ Q (CFNP (CADDR X)))
(CONS Q (QUOTE (MACROX]
(T (SETQ LL
(CONS [LIST (QUOTE MACROF2)
(LIST (QUOTE OR)
(CADDR X)
(QUOTE (QUOTE CDR]
LL))
(QUOTE (APPLY* MACROF2 MACROX]
(T (QUOTE (CDR MACROX]
LL)
(QUOTE (PROG ((MACROX MAPX) . B)
MAPCLP
(COND ((NLISTP MACROX)
(RETURN NIL))
(MAPCF (RETURN MACROX)))
(SETQ MACROX MAPCF2)
(GO MAPCLP]
))(QUOTE MACRO))
STOP